２９−７４．指定したセルへ画像を貼り付け
○●●
ワークシートに画像を張付ける場合、マニアル操作でメニューから
[挿入][図][ファイルから]を選択して画像フェイルを指定して貼り付け
その後任意の場所に移動すると共にサイズを変更すれば希望のセルへ
画像を張付けることが出来す。
しかし、ワークシートへ多数の画像を張付ける場合マニアル操作は
面倒であり、下記マクロでセル範囲を指定し簡単に貼り付けることが
できます。（本例ではセル範囲は固定になっていますが実際の使用では
インプットボックスで行なうとよい）（サンプル掲載「KIgazou1」)
Sub Macro1()
'セル範囲
Set scel = Range(Cells(2, 2), Cells(12, 5))
scel.Select
x = ActiveCell.Column
y = ActiveCell.Row
x2 = Selection.Width
y2 = Selection.Height
Range("A1").Select
fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい")
If fname = False Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(fname).Select
Selection.Name = "gazou"
Set 画像 = ActiveSheet.Shapes("gazou")
With 画像
.LockAspectRatio = False
' .LockAspectRatio = True '比率変換
.Placement = xlFreeFloating
.ScaleHeight 1, True
.ScaleWidth 1, True
.Left = Cells(y, x).Left
.Top = Cells(y, x).Top
.Width = x2
.Height = y2
End With
Range("A1").Select
End Sub
・上記の.LockAspectRatio = FalseをTrue にかえれば比率変換となります。
・図形の指定は必要に応じ「*.jpge;*.tif;*.tiff」等を追加して下さい。
２９−７５．画像を分割して貼り付け
○●●
前項で指定したセルへ貼り付けたが、これはマニアル操作でも出来ることであり、
マクロとしては画像を分割し貼り付けることが出来ないか考えて作成したのが
下記マクロです。
・下記例では分割数を縦・横とも５個
・分割画像を別の場所に貼り付ける場合は、選択状態にしてドラッグする。
・複数個を選択する場合はShiftキーを押しながら実行
・なお、移動させた画像は選択状態で右クリックしてショートタットメニュのグループ化
指定で1個の画像になります。
・分割と表示倍率をユーザーフォームで指定するサンプル掲載は、[KIgazou2]
Dim 絵1 As Object '分割用の絵
Dim bw As Single '分割の1個の横幅
Dim bww As Single '分割の1個の横幅
Dim bh As Single '分割の1個の縦幅
Dim bhh As Single '分割の1個の縦幅
Dim ien As Integer '横の分割数
Dim jen As Integer '縦の分割数
Dim i As Integer '横
Dim j As Integer '縦
Dim yoko As Integer '横
Dim tate As Integer '縦
Sub 分割実行()
ien = 5 '分割横数
jen = 5 '分割縦数
'画像ファイル指定
fname = Application.GetOpenFilename _
("画像ファイル,*.gif;*.jpg;*.bmp", 1, "画像ファイルを指定して下さい")
If fname = False Then
Exit Sub
End If
Application.ScreenUpdating = False
ActiveSheet.Pictures.Insert(fname).Select
Selection.Name = "gazou"
'分割の1個の縦横幅
Set 絵 = ActiveSheet.Shapes("gazou")
bww = 絵.Width
bw = CInt(bww / ien)
bhh = 絵.Height
bh = CInt(bhh / jen)
'元の絵
Set 絵 = ActiveSheet.Shapes("gazou")
With 絵
.LockAspectRatio = True
.Placement = xlFreeFloating
.ScaleHeight 1, False
.ScaleWidth 1, False
.Left = Cells(2, 2).Left
.Top = Cells(2, 2).Top
End With
bunno = 1
For i = 1 To ien
For j = 1 To jen
'分割用の絵
Set 絵1 = 絵.Duplicate
絵1.Select
絵1.Left = Cells(2, 2).Left
絵1.Top = Cells(2, 2).Top
'縦横の位置
yoko = (bunno - 1) Mod ien + 1
tate = (bunno - 1) \ ien + 1
絵1.LockAspectRatio = False
With 絵1.PictureFormat
.CropLeft = bw * (yoko - 1) - 0.115
.CropRight = bww - (bw * yoko)
.CropTop = bh * (tate - 1) - 0.1111
.CropBottom = bhh - (bh * tate)
End With
bunno = bunno + 1
Set 絵1 = Nothing
Next
Next
絵.Delete
Range("A4").Select
End Sub
・".ScaleHeight 1, False"の1は倍率であり変更により表示サイズが変わる。
・"絵.Delete"で元の絵を削除してあるが、この指定が無い場合は下絵が残ります。
・表示とトリミングのポイント位置は同じにしたはずだが、空白が出来たので
- 0.115、 - 0.1111で補正した（適当に入れた数字で特に根拠なし)。
２９−７６．オリジナルツールバーの作成
○●●
本例は画像をオートシェイブの枠型を使用し切り抜くマクロを作成した時、
作成したオリジナルツールバーの作成例です。画像切抜きサンプルは
「KIgif」
本マクロ実行で下図のツールバーが作成できます。
Sub bar()
Dim cb As CommandBar
On Error Resume Next
CommandBars("mycb").Delete
On Error GoTo 0
Set cb = Application.CommandBars.Add(Name:="mycb", temporary:=True)
With cb
.Controls.Add Type:=msoControlButton, ID:=1111, before:=1
.Controls.Add Type:=msoControlButton, ID:=1115, before:=2
.Controls.Add Type:=msoControlButton, ID:=1129, before:=3
.Controls.Add Type:=msoControlButton, ID:=1125, before:=4
.Controls.Add Type:=msoControlButton, ID:=1114, before:=5
.Controls.Add Type:=msoControlButton, ID:=1120, before:=6
.Controls.Add Type:=msoControlButton, ID:=1121, before:=7
.Controls.Add Type:=msoControlButton, ID:=1123, before:=8
.Controls.Add Type:=msoControlButton, ID:=1116, before:=9
.Controls.Add Type:=msoControlButton, ID:=1119, before:=10
.Controls.Add Type:=msoControlButton, ID:=1141, before:=11
.Controls.Add Type:=msoControlButton, ID:=1183, before:=12
.Controls.Add Type:=msoControlButton, ID:=1188, before:=13
.Controls.Add Type:=msoControlButton, ID:=200, before:=14
.Visible = True
.Position = msoBarTop
End With
Set cb1 = cb.Controls.Add(Type:=msoControlButton, before:=15)
With cb1
.BeginGroup = True
.Caption = "キャンセル"
.FaceId = 128
.OnAction = "キャンセル"
End With
Set cb2 = cb.Controls.Add(Type:=msoControlButton, before:=16)
With cb2
.Caption = "枠内を透過にする"
.FaceId = 59
.OnAction = "透過"
End With
Set cb3 = cb.Controls.Add(Type:=msoControlButton, before:=17)
With cb3
.Caption = "切取り(透過を先実行の事)"
.FaceId = 21
.OnAction = "切取"
End With
End Sub
[1] ツールバーは毎回作成の関係で前のは削除CommandBars("mycb").Delete（無い場合の対応が必要）
[2] temporary:=True でExcel終了で本ツールバーは消える。
[3] .BeginGroup = True → ツールバーに区切りの縦線を入れる
[4] .Caption = "枠内を透過にする" → マウスが来た時の説明文
[5] .FaceId = 59 → 表示するアイコン
[6] .OnAction = "透過" → アイコンをクリックした時実行するマクロ
[7] .Position = msoBarTop → ツールバーをトップへ表示
参考２９-１０ ピクセルの簡単な求め方(Excel2000)
○○●Excelシートに画像を表示して、オートシェイブから
枠型を選択してその画像に貼付け、枠型の表示位置を求めるマクロを作成
したが、表示位置はピクセル（クリッカブルマップデータで使用）に
変換する必要があり考えた。なお、画面の解像度を変えて
（640*480、800*600、1024*768）試して見たが自分のPCで行なった限り
では同じ結果だった。
[1]上図のように列と列の切れ目の個所を選択する。
[2]十字マークをクリックすると、テキストボックスのカッコ内にピクセル数が表示される。
[3]次に自動記録で、セルの幅に合わせて図形を書く（本例の場合Buttonで下記が記録内容）。
[4]自動記録から取得したセル幅（ポイント）と[2]ピクセル数を使用して算出。
[5]結果：100ピクセル/75ポイント＝4/3 となる。
[6]変換式：ピクセル数＝ポイント数×4/3、ポイント数＝ピクセル数×3/4
Sub Macro1()
ActiveSheet.Buttons.Add(108, 13.5, 75, 13.5).Select
End Sub
(29-1〜29-20)
(29-21〜29-35)
(29-36〜29-50)
(29-51〜29-61)
(29-62〜29-73)
(29-74〜 )
目次へ戻る